home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-02 / opxms114.zip / EXXMS.PAS < prev    next >
Pascal/Delphi Source File  |  1990-11-12  |  4KB  |  157 lines
  1. {$R-,S-,V-}
  2. program XmsTest;
  3.  
  4. uses Crt, OpString, OpXms;
  5.  
  6. const
  7.   XmsStr : String[15] = 'Hello XMS world';
  8.  
  9. procedure MoveTest;
  10. var
  11.   Err : Byte;
  12.   Handle : Word;
  13.   ps, pd : ExtMemPtr;
  14.   S : String[15];
  15.  
  16. begin
  17.   WriteLn('Performing Move Test');
  18.   Err := AllocateExtMem(1, Handle);
  19.   WriteLn('AllocateExtMem: ', XmsErrorString(Err));
  20.   if Err <> 0 then
  21.     Exit;
  22.   ps.RealPtr := @XmsStr;
  23.   pd.ProtectedPtr := 0;
  24.   Err := MoveExtMemBlock(Succ(Length(XmsStr)), 0, ps, Handle, pd);
  25.   WriteLn('MoveExtMemBlock: ', XmsErrorString(Err));
  26.   if Err <> 0 then begin
  27.     Err := FreeExtMem(Handle);
  28.     Exit;
  29.   end;
  30.   FillChar(S, SizeOf(S), 0);
  31.   pd.RealPtr := @S;
  32.   ps.ProtectedPtr := 0;
  33.   Err := MoveExtMemBlock(Succ(Length(XmsStr)), Handle, ps, 0, pd);
  34.   if Err = 0 then
  35.     WriteLn(S);
  36.   WriteLn('MoveExtMemBlock: ', XmsErrorString(Err));
  37.   Err := FreeExtMem(Handle);
  38.   WriteLn('FreeExtMem: ', XmsErrorString(Err));
  39. end;
  40.  
  41. procedure AllocateTest;
  42. var
  43.   Total, Largest, Handle : Word;
  44.   Err : Byte;
  45. begin
  46.   WriteLn('Performing Allocate Test');
  47.   Err := QueryFreeExtMem(Total, Largest);
  48.   WriteLn('Total   = ', Total);
  49.   WriteLn('Largest = ', Largest);
  50.   Err := AllocateExtMem(Largest, Handle);
  51.   WriteLn('Attempt to allocate ', Largest,'K of XMS returned: ', XmsErrorString(Err));
  52.   Err := FreeExtMem(Handle);
  53.   WriteLn('Attempt to free extended memory block returned: ', XmsErrorString(Err));
  54.   Err := AllocateExtMem(Largest+1, Handle);
  55.   WriteLn('Attempt to allocate ', Largest+1,'K of XMS returned: ', XmsErrorString(Err));
  56. end;
  57.  
  58. procedure HMATest;
  59. var
  60.   Err : Byte;
  61. begin
  62.   WriteLn('Performing HMA Test');
  63.   Err := RequestHMA($FFFF);
  64.   WriteLn('RequestHMA returned: ', XmsErrorString(Err));
  65.   if Err = 0 then begin
  66.     Err := ReleaseHMA;
  67.     WriteLn('ReleaseHMA returned: ', XmsErrorString(Err));
  68.   end;
  69. end;
  70.  
  71. procedure LockTest;
  72. var
  73.   Handle : Word;
  74.   Err : Byte;
  75.   LinearPtr : ExtMemPtr;
  76.  
  77. begin
  78.   WriteLn('Performing Lock Test');
  79.   Err := AllocateExtMem(1, Handle);
  80.   WriteLn('Attempt to allocate 1K of XMS returned: ', XmsErrorString(Err));
  81.   Err := LockExtMemBlock(Handle, LinearPtr);
  82.   WriteLn('LockExtMemBlock returned: ', XmsErrorString(Err));
  83.   if Err = 0 then
  84.     WriteLn('Block''s 32 bit linear address = $', HexL(LinearPtr.ProtectedPtr));
  85.   Err := UnlockExtMemBlock(Handle);
  86.   WriteLn('UnlockExtMemBlock returned: ', XmsErrorString(Err));
  87.   Err := FreeExtMem(Handle);
  88.   WriteLn('Attempt to free extended memory block returned: ', XmsErrorString(Err));
  89. end;
  90.  
  91. procedure ResizeTest;
  92. var
  93.   Handle : Word;
  94.   Err : Byte;
  95. begin
  96.   WriteLn('Performing Resize Test');
  97.   Err := AllocateExtMem(1, Handle);
  98.   WriteLn('Attempt to allocate 1K of XMS returned: ', XmsErrorString(Err));
  99.  
  100.   Err := ResizeExtMemBlock(Handle, 2);
  101.   WriteLn('ResizeExtMemBlock returned: ', XmsErrorString(Err));
  102.  
  103.   Err := FreeExtMem(Handle);
  104.   WriteLn('Attempt to free extended memory block returned: ', XmsErrorString(Err));
  105. end;
  106.  
  107. procedure UMBTest;
  108. var
  109.   Largest, SegBase : Word;
  110.   Err : Byte;
  111.   P : ^String;
  112. begin
  113.   WriteLn('Performing Upper Memory Block Test');
  114.   Err := AllocUpperMemBlock($FFFF, SegBase, Largest);
  115.   if Err = FuncNotImplemented then begin
  116.     WriteLn('Upper memory block functions are not implemented by this XMS driver');
  117.     Exit;
  118.   end;
  119.   WriteLn('The largest upper memory block available is ', Largest*16);
  120.   Err := AllocUpperMemBlock(Largest, SegBase, Largest);
  121.   WriteLn('Attempt to allocate ', Largest*16,' byte UMB: ', XmsErrorString(Err));
  122.   if Err <> 0 then
  123.     Exit;
  124.   P := Ptr(SegBase, 0);
  125.   P^ := XmsStr;
  126.   WriteLn(P^);
  127.   Err := FreeUpperMemBlock(SegBase);
  128.   WriteLn('FreeUpperMemBlock returned: ', XmsErrorString(Err));
  129. end;
  130.  
  131. procedure Pause;
  132.  
  133. begin
  134.   Write('Press any key to continue');
  135.   if ReadKey = #0 then ;
  136.   WriteLn;
  137. end;
  138.  
  139. begin
  140.   if not XmsInstalled then begin
  141.     WriteLn('There is no XMS memory manager installed.');
  142.     Halt;
  143.   end;
  144.   WriteLn('XMS Control function at ', HexPtr(XmsControl));
  145.   HMATest;
  146.   Pause;
  147.   AllocateTest;
  148.   Pause;
  149.   MoveTest;
  150.   Pause;
  151.   LockTest;
  152.   Pause;
  153.   ResizeTest;
  154.   Pause;
  155.   UMBTest;
  156. end.
  157.